home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0080_English Number Strings.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  3KB  |  108 lines
  1. {$S-,R-,V-,I-,N-,B-,F-}
  2.  
  3. {
  4.    Converts REAL number to ENGLISH strings
  5.    GAYLE DAVIS 1/21/94
  6.    Amounts up to and including $19,999,999.99 are supported.
  7.    If you write amounts larger than that, you don't need a computer !!
  8.    ======================================================================
  9.    Dedicated to the PUBLIC DOMAIN, this software code has been tested and
  10.    used under BP 7.0/DOS and MS-DOS 6.2.
  11. }
  12.  
  13. {$IFNDEF Ver40}
  14.   {Allow overlays}
  15.   {$F+,O-,X+,A-}
  16. {$ENDIF}
  17.  
  18. USES CRT;
  19.  
  20. CONST
  21.      Dot : CHAR = #42;
  22.  
  23. VAR
  24.     SS : STRING;
  25.     AA : REAL;
  26.  
  27. FUNCTION EnglishNumber (Amt : REAL) : STRING;
  28.  
  29. TYPE
  30.   Mword = STRING [10];
  31.   Amstw = STRING [80];  {for function TenUnitToWord output}
  32.  
  33. CONST
  34.   NumStr : ARRAY [0..27] OF Mword =
  35.          ('', 'ONE ', 'TWO ', 'THREE ', 'FOUR ', 'FIVE ', 'SIX ', 'SEVEN ',
  36.           'EIGHT ','NINE ', 'TEN ', 'ELEVEN ', 'TWELVE ', 'THIRTEEN ',
  37.           'FOURTEEN ', 'FIFTEEN ', 'SIXTEEN ', 'SEVENTEEN ', 'EIGHTEEN ',
  38.           'NINETEEN ', 'TWENTY ', 'THIRTY ', 'FORTY ', 'FIFTY ', 'SIXTY ',
  39.           'SEVENTY ', 'EIGHTY ', 'NINETY ');
  40. VAR
  41.   S               : STRING;
  42.   Temp            : REAL;
  43.   DigitA, DigitB  : INTEGER;
  44.   Ams             : STRING;
  45.   Ac              : STRING [2];
  46.  
  47. FUNCTION TenUnitToWord (TeUn : INTEGER) : Amstw;
  48.          { convert tens and units to words }
  49.   BEGIN
  50.     IF TeUn < 21 THEN TenUnitToWord := NumStr [TeUn]
  51.       ELSE TenUnitToWord := NumStr [TeUn DIV 10 + 18] + NumStr [TeUn MOD 10];
  52.   END; {function TenUnitToWord}
  53.  
  54. BEGIN
  55.  
  56.   { Nothing bigger than 20 million }
  57.   IF (Amt > 20000000.0) OR (Amt <= 0.0) THEN
  58.     BEGIN
  59.       EnglishNumber := '';  {null string if out of range}
  60.       EXIT;
  61.     END;
  62.   { Convert 1,000,000 decade }
  63.   Ams := '';
  64.   DigitA := TRUNC (Amt / 1E6);
  65.   IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'MILLION ';
  66.   Temp := Amt - DigitA * 1E6;
  67.  
  68.   { Convert 100,000, 10,000, 1,000 decades }
  69.  
  70.   DigitA := TRUNC (Temp / 1E5);         {extract 100,000 decade}
  71.   IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'HUNDRED ';
  72.   Temp := Temp - DigitA * 1E5;
  73.   DigitB := TRUNC (Temp / 1000);        {extract sum of 10,000 and 1,000 decades}
  74.   Ams := Ams + TenUnitToWord (DigitB);
  75.   IF ( (DigitA > 0) OR (DigitB > 0) ) THEN Ams := Ams + 'THOUSAND ';
  76.  
  77.   {Convert 100, 10, unit decades}
  78.  
  79.   Temp := Temp - DigitB * 1000.0;
  80.   DigitA := TRUNC (Temp / 100);          {extract 100 decade}
  81.   IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'HUNDRED ';
  82.   DigitB := TRUNC (Temp - DigitA * 100.0);  {extract sum of 10 and unit decades}
  83.   Ams := Ams + TenUnitToWord (DigitB);
  84.  
  85.   {Convert cents to form XX/100}
  86.  
  87.   IF INT (Amt) > 0.0 THEN Ams := Ams + 'AND ';
  88.   DigitA := ROUND ( (FRAC (Amt) * 100) );
  89.   IF DigitA > 0 THEN
  90.     BEGIN
  91.       STR (DigitA : 2, Ac);
  92.       IF Ac [1] = ' ' THEN Ac [1] := '0';
  93.       Ams := Ams + Ac + '/100'
  94.     END
  95.   ELSE Ams := Ams + 'NO/100';
  96.  
  97.   EnglishNumber := Ams + ' Dollars';
  98.  
  99. END;
  100.  
  101. BEGIN
  102. ClrScr;
  103. WriteLn(EnglishNumber (1234.55));
  104. WriteLn(EnglishNumber (991234.55));
  105. WriteLn(EnglishNumber (19891234.55));
  106. Readkey;
  107. END.
  108.